home *** CD-ROM | disk | FTP | other *** search
/ PC Open 107 / PC Open 107 CD 1.bin / CD1 / INTERNET / EMAIL / pop file / setup.exe / POPFile / History.pm < prev    next >
Encoding:
Perl POD Document  |  2004-12-15  |  40.2 KB  |  1,349 lines
  1. # POPFILE LOADABLE MODULE
  2. package POPFile::History;
  3.  
  4. use POPFile::Module;
  5. @ISA = ("POPFile::Module");
  6.  
  7. #----------------------------------------------------------------------------
  8. #
  9. # This module handles POPFile's history.  It manages entries in the POPFile
  10. # database and on disk that store messages previously classified by POPFile.
  11. #
  12. # Copyright (c) 2004 John Graham-Cumming
  13. #
  14. #   This file is part of POPFile
  15. #
  16. #   POPFile is free software; you can redistribute it and/or modify
  17. #   it under the terms of the GNU General Public License as published by
  18. #   the Free Software Foundation; either version 2 of the License, or
  19. #   (at your option) any later version.
  20. #
  21. #   POPFile is distributed in the hope that it will be useful,
  22. #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  23. #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24. #   GNU General Public License for more details.
  25. #
  26. #   You should have received a copy of the GNU General Public License
  27. #   along with POPFile; if not, write to the Free Software
  28. #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  29. #
  30. #----------------------------------------------------------------------------
  31.  
  32. use strict;
  33. use warnings;
  34. use locale;
  35.  
  36. use Date::Parse;
  37. use Digest::MD5 qw( md5_hex );
  38.  
  39. my $fields_slot = 'history.id, hdr_from, hdr_to, hdr_cc, hdr_subject,
  40. hdr_date, hash, inserted, buckets.name, usedtobe, history.bucketid, magnets.val, size';
  41.  
  42. #----------------------------------------------------------------------------
  43. # new
  44. #
  45. #   Class new() function
  46. #----------------------------------------------------------------------------
  47. sub new
  48. {
  49.     my $proto = shift;
  50.     my $class = ref($proto) || $proto;
  51.     my $self = POPFile::Module->new();
  52.  
  53.     # List of committed history items waiting to be committed
  54.     # into the database, it consists of lists containing three
  55.     # elements: the slot id, the bucket classified to and the
  56.     # magnet if used
  57.  
  58.     $self->{commit_list__} = ();
  59.  
  60.     # Contains queries started with start_query and consists
  61.     # of a mapping between unique IDs and quadruples containing
  62.     # a reference to the SELECT and a cache of already fetched
  63.     # rows and a total row count.  These quadruples are implemented
  64.     # as a sub-hash with keys query, count, cache, fields
  65.  
  66.     $self->{queries__} = ();
  67.  
  68.     $self->{firsttime__} = 1;
  69.  
  70.     # Will contain the database handle retrieved from
  71.     # Classifier::Bayes
  72.  
  73.     $self->{db__} = undef;
  74.  
  75.     $self->{classifier__} = 0;
  76.  
  77.     bless($self, $class);
  78.  
  79.     $self->name( 'history' );
  80.  
  81.     return $self;
  82. }
  83.  
  84. #----------------------------------------------------------------------------
  85. #
  86. # initialize
  87. #
  88. # Called to initialize the history module
  89. #
  90. #----------------------------------------------------------------------------
  91. sub initialize
  92. {
  93.     my ( $self ) = @_;
  94.  
  95.     # Keep the history for two days
  96.  
  97.     $self->config_( 'history_days', 2 );
  98.  
  99.     # If 1, Messages are saved to an archive when they are removed or expired
  100.     # from the history cache
  101.  
  102.     $self->config_( 'archive', 0 );
  103.  
  104.     # The directory where messages will be archived to, in sub-directories for
  105.     # each bucket
  106.  
  107.     $self->config_( 'archive_dir', 'archive' );
  108.  
  109.     # This is an advanced setting which will save archived files to a
  110.     # randomly numbered sub-directory, if set to greater than zero, otherwise
  111.     # messages will be saved in the bucket directory
  112.     #
  113.     # 0 <= directory name < archive_classes
  114.  
  115.     $self->config_( 'archive_classes', 0 );
  116.  
  117.     # Need TICKD message for history clean up, COMIT when a message
  118.     # is committed to the history
  119.  
  120.     $self->mq_register_( 'TICKD', $self );
  121.     $self->mq_register_( 'COMIT', $self );
  122.  
  123.     return 1;
  124. }
  125.  
  126. #----------------------------------------------------------------------------
  127. #
  128. # stop
  129. #
  130. # Called to stop the history module
  131. #
  132. #----------------------------------------------------------------------------
  133. sub stop
  134. {
  135.     my ( $self ) = @_;
  136.  
  137.     # Commit any remaining history items.  This is needed because it's
  138.     # possible that we get called with a stop after things have been
  139.     # added to the queue and before service() is called
  140.  
  141.     $self->commit_history__();
  142. }
  143.  
  144. #----------------------------------------------------------------------------
  145. #
  146. # db__
  147. #
  148. # Since we don't know the order in which the start() methods of PLMs
  149. # is called we cannot be sure that Classifier::Bayes will have started
  150. # and connected to the database before us, hence we can't set our
  151. # database handle at start time.  So instead we access the db handle
  152. # through this method
  153. #
  154. #----------------------------------------------------------------------------
  155. sub db__
  156. {
  157.     my ( $self ) = @_;
  158.  
  159.     if ( !defined( $self->{db__} ) ) {
  160.         $self->{db__} = $self->{classifier__}->db()->clone;
  161.     }
  162.  
  163.     return $self->{db__};
  164. }
  165.  
  166. #----------------------------------------------------------------------------
  167. #
  168. # service
  169. #
  170. # Called periodically so that the module can do its work
  171. #
  172. #----------------------------------------------------------------------------
  173. sub service
  174. {
  175.     my ( $self ) = @_;
  176.  
  177.     if ( $self->{firsttime__} ) {
  178.         $self->upgrade_history_files__();
  179.         $self->{firsttime__} = 0;
  180.     }
  181.  
  182.     # Note when we go to multiuser POPFile we'll need to change this call
  183.     # so that we are sure that the session IDs that it is using are still
  184.     # valid.  The easiest way will be to call it in deliver() when we get
  185.     # a COMIT message.
  186.  
  187.     $self->commit_history__();
  188.  
  189.     return 1;
  190. }
  191.  
  192. #----------------------------------------------------------------------------
  193. #
  194. # deliver
  195. #
  196. # Called by the message queue to deliver a message
  197. #
  198. # There is no return value from this method
  199. #
  200. #----------------------------------------------------------------------------
  201. sub deliver
  202. {
  203.     my ( $self, $type, @message ) = @_;
  204.  
  205.     # If a day has passed then clean up the history
  206.  
  207.     if ( $type eq 'TICKD' ) {
  208.         $self->cleanup_history();
  209.     }
  210.  
  211.     if ( $type eq 'COMIT' ) {
  212.         push ( @{$self->{commit_list__}}, \@message );
  213.     }
  214. }
  215.  
  216. # ---------------------------------------------------------------------------
  217. #
  218. # forked
  219. #
  220. # This is called inside a child process that has just forked, since the
  221. # child needs access to the database we open it
  222. #
  223. # ---------------------------------------------------------------------------
  224. sub forked
  225. {
  226.     my ( $self ) = @_;
  227.  
  228.     $self->{db__} = undef;
  229. }
  230.  
  231. #----------------------------------------------------------------------------
  232. #
  233. # ADDING TO THE HISTORY
  234. #
  235. # To add a message to the history the following sequence of calls
  236. # is made:
  237. #
  238. # 1. Obtain a unique ID and filename for the new message by a call
  239. #    to reserve_slot
  240. #
  241. # 2. Write the message into the filename returned
  242. #
  243. # 3. Call commit_slot with the bucket into which the message was
  244. #    classified
  245. #
  246. # If an error occurs after #1 and the slot is unneeded then call
  247. # release_slot
  248. #
  249. #----------------------------------------------------------------------------
  250. #
  251. # FINDING A HISTORY ENTRY
  252. #
  253. # 1. If you know the slot id then call get_slot_file to obtain
  254. #    the full path where the file is stored
  255. #
  256. # 2. If you know the message hash then call get_slot_from hash
  257. #    to get the slot id
  258. #
  259. # 3. If you know the message headers then use get_message_hash
  260. #    to get the hash
  261. #
  262. #----------------------------------------------------------------------------
  263.  
  264. #----------------------------------------------------------------------------
  265. #
  266. # reserve_slot
  267. #
  268. # Called to reserve a place in the history for a message that is in the
  269. # process of being received.  It returns a unique ID for this slot and
  270. # the full path to the file where the message should be stored.  The
  271. # caller is expected to later call either release_slot (if the slot is not
  272. # going to be used) or commit_slot (if the file has been written and the
  273. # entry should be added to the history).
  274. #
  275. #----------------------------------------------------------------------------
  276. sub reserve_slot
  277. {
  278.     my ( $self ) = @_;
  279.  
  280.     my $r;
  281.  
  282.     while (1) {
  283.         $r = int(rand( 1000000000 )+2);
  284.  
  285.         $self->log_( 2, "reserve_slot selected random number $r" );
  286.  
  287.         # TODO Replace the hardcoded user ID 1 with the looked up
  288.         # user ID from the session key
  289.  
  290.         my $test = $self->db__()->selectrow_arrayref(
  291.                  "select id from history where committed = $r limit 1;");
  292.  
  293.         if ( defined( $test ) ) {
  294.             next;
  295.         }
  296.  
  297.         # Get the date/time now which will be stored in the database
  298.         # so that we can sort on the Date: header in the message and
  299.         # when we received it
  300.  
  301.         my $now = time;
  302.         $self->db__()->do(
  303.             "insert into history ( userid, committed, inserted ) values ( 1, $r, $now );" );
  304.         last;
  305.     }
  306.  
  307.     my $result = $self->db__()->selectrow_arrayref(
  308.                  "select id from history where committed = $r limit 1;");
  309.  
  310.     my $slot = $result->[0];
  311.  
  312.     $self->log_( 2, "reserve_slot returning slot id $slot" );
  313.  
  314.     return ( $slot, $self->get_slot_file( $slot ) );
  315. }
  316.  
  317. #----------------------------------------------------------------------------
  318. #
  319. # release_slot
  320. #
  321. # See description with reserve_slot; release_slot releases a history slot
  322. # previously allocated with reserve_slot and discards it.
  323. #
  324. # id              Unique ID returned by reserve_slot
  325. #
  326. #----------------------------------------------------------------------------
  327. sub release_slot
  328. {
  329.     my ( $self, $slot ) = @_;
  330.  
  331.     # Remove the entry from the database and delete the file
  332.     # if present
  333.  
  334.     my $delete = "delete from history where history.id = $slot;";
  335.  
  336.     $self->db__()->do( $delete );
  337.  
  338.     my $file = $self->get_slot_file( $slot );
  339.  
  340.     unlink $file;
  341.  
  342.     # It's not possible that the directory for the slot file is empty
  343.     # and we want to delete it so that things get cleaned up automatically
  344.  
  345.     $file =~ s/popfile[a-f0-9]{2}\.msg$//i;
  346.  
  347.     my $depth = 3;
  348.  
  349.     while ( $depth > 0 ) {
  350.         my @files = glob( $file . '*' );
  351.  
  352.         if ( $#files == -1 ) {
  353.             if ( !( rmdir( $file ) ) ) {
  354.                 last;
  355.             }
  356.             $file =~ s![a-f0-9]{2}/$!!i;
  357.         } else {
  358.             last;
  359.         }
  360.  
  361.         $depth--;
  362.     }
  363. }
  364.  
  365. #----------------------------------------------------------------------------
  366. #
  367. # commit_slot
  368. #
  369. # See description with reserve_slot; commit_slot commits a history
  370. # slot to the database and makes it part of the history.  Before this
  371. # is called the full message should have been written to the file
  372. # returned by reserve_slot.  Note that commit_slot queues the message
  373. # for insertion and does not commit it until some (short) time later
  374. #
  375. # session         User session with Classifier::Bayes API
  376. # slot            Unique ID returned by reserve_slot
  377. # bucket          Bucket classified to
  378. # magnet          Magnet if used
  379. #
  380. #----------------------------------------------------------------------------
  381. sub commit_slot
  382. {
  383.     my ( $self, $session, $slot, $bucket, $magnet ) = @_;
  384.  
  385.     $self->mq_post_( 'COMIT', $session, $slot, $bucket, $magnet );
  386. }
  387.  
  388. #----------------------------------------------------------------------------
  389. #
  390. # change_slot_classification
  391. #
  392. # Used to 'reclassify' a message by changing its classification in the
  393. # database.
  394. #
  395. # slot         The slot to update
  396. # class        The new classification
  397. # session      A valid API session
  398. # undo         If set to 1 then indicates an undo operation
  399. #
  400. #----------------------------------------------------------------------------
  401. sub change_slot_classification
  402. {
  403.     my ( $self, $slot, $class, $session, $undo ) = @_;
  404.  
  405.     $self->log_( 0, "Change slot classification of $slot to $class" );
  406.  
  407.     # Get the bucket ID associated with the new classification
  408.     # then retrieve the current classification for this slot
  409.     # and update the database
  410.  
  411.     my $bucketid = $self->{classifier__}->get_bucket_id(
  412.                            $session, $class );
  413.  
  414.     my $oldbucketid = 0;
  415.     if ( !$undo ) {
  416.         my @fields = $self->get_slot_fields( $slot );
  417.         $oldbucketid = $fields[10];
  418.     }
  419.  
  420.     $self->db__()->do( "update history set bucketid = $bucketid,
  421.                                            usedtobe = $oldbucketid
  422.                                        where id = $slot;" );
  423.     $self->force_requery__();
  424. }
  425.  
  426. #----------------------------------------------------------------------------
  427. #
  428. # revert_slot_classification
  429. #
  430. # Used to undo a 'reclassify' a message by changing its classification
  431. # in the database.
  432. #
  433. # slot         The slot to update
  434. #
  435. #----------------------------------------------------------------------------
  436. sub revert_slot_classification
  437. {
  438.     my ( $self, $slot ) = @_;
  439.  
  440.     my @fields = $self->get_slot_fields( $slot );
  441.     my $oldbucketid = $fields[9];
  442.  
  443.     $self->db__()->do( "update history set bucketid = $oldbucketid,
  444.                                            usedtobe = 0
  445.                                        where id = $slot;" );
  446.     $self->force_requery__();
  447. }
  448.  
  449. #---------------------------------------------------------------------------
  450. #
  451. # get_slot_fields
  452. #
  453. # Returns the fields associated with a specific slot.  We return the
  454. # same collection of fields as get_query_rows.
  455. #
  456. # slot           The slot id
  457. #
  458. #---------------------------------------------------------------------------
  459. sub get_slot_fields
  460. {
  461.     my ( $self, $slot ) = @_;
  462.  
  463.     return $self->db__()->selectrow_array(
  464.         "select $fields_slot from history, buckets, magnets
  465.              where history.id = $slot and
  466.                    buckets.id = history.bucketid and
  467.                    magnets.id = magnetid;" );
  468. }
  469.  
  470. #---------------------------------------------------------------------------
  471. #
  472. # is_valid_slot
  473. #
  474. # Returns 1 if the slot ID passed in is valid
  475. #
  476. # slot           The slot id
  477. #
  478. #---------------------------------------------------------------------------
  479. sub is_valid_slot
  480. {
  481.     my ( $self, $slot ) = @_;
  482.  
  483.     my @row = $self->db__()->selectrow_array(
  484.         "select id from history where history.id = $slot;" );
  485.  
  486.     return ( ( @row ) && ( $row[0] == $slot ) );
  487. }
  488.  
  489. #---------------------------------------------------------------------------
  490. #
  491. # commit_history__
  492. #
  493. # (private) Used internally to commit messages that have been committed
  494. # with a call to commit_slot to the database
  495. #
  496. #----------------------------------------------------------------------------
  497. sub commit_history__
  498. {
  499.     my ( $self ) = @_;
  500.  
  501.     if ( $#{$self->{commit_list__}} == -1 ) {
  502.         return;
  503.     }
  504.  
  505.     foreach my $entry (@{$self->{commit_list__}}) {
  506.         my ( $session, $slot, $bucket, $magnet ) = @{$entry};
  507.  
  508.         my $file = $self->get_slot_file( $slot );
  509.  
  510.         # Committing to the history requires the following steps
  511.         #
  512.         # 1. Parse the message to extract the headers
  513.         # 2. Compute MD5 hash of Message-ID, Date and Subject
  514.         # 3. Update the related row with the headers and
  515.         #    committed set to 1
  516.  
  517.         my %header;
  518.  
  519.         if ( open FILE, "<$file" ) {
  520.             my $last;
  521.             while ( <FILE> ) {
  522.                 s/[\r\n]//g;
  523.  
  524.                 if ( /^$/ ) {
  525.                     last;
  526.                 }
  527.  
  528.                 if ( /^([^ \t]+):[ \t]*(.*)$/ ) {
  529.                     $last = lc $1;
  530.                     push @{$header{$last}}, $2;
  531.  
  532.                 } else {
  533.                     if ( defined $last ) {
  534.                         ${$header{$last}}[$#{$header{$last}}] .= $_;
  535.                     }
  536.                 }
  537.             }
  538.             close FILE;
  539.         }
  540.         else {
  541.             $self->log_( 0, "Could not open history message file $file for reading." );
  542.         }
  543.  
  544.         my $hash = $self->get_message_hash( ${$header{'message-id'}}[0],
  545.                                             ${$header{'date'}}[0],
  546.                                             ${$header{'subject'}}[0],
  547.                                             ${$header{'received'}}[0] );
  548.         $hash = $self->db__()->quote( $hash );
  549.  
  550.         # For sorting purposes the From, To and CC headers have special
  551.         # cleaned up versions of themselves in the database.  The idea
  552.         # is that case and certain characters should be ignored when
  553.         # sorting these fields
  554.         #
  555.         # "John Graham-Cumming" <spam@jgc.org> maps to
  556.         #     john graham-cumming spam@jgc.org
  557.  
  558.         my @sortable = ( 'from', 'to', 'cc' );
  559.         my %sort_headers;
  560.  
  561.         foreach my $h (@sortable) {
  562.             $sort_headers{$h} =
  563.                  $self->{classifier__}->{parser__}->decode_string(
  564.                      ${$header{$h}}[0] );
  565.             $sort_headers{$h} = lc($sort_headers{$h} || '');
  566.             $sort_headers{$h} =~ s/[\"<>]//g;
  567.             $sort_headers{$h} =~ s/^[ \t]+//g;
  568.             $sort_headers{$h} =~ s/\0//g;
  569.             $sort_headers{$h} = $self->db__()->quote(
  570.                 $sort_headers{$h} );
  571.         }
  572.  
  573.         # Make sure that the headers we are going to insert into
  574.         # the database have been defined and are suitably quoted
  575.  
  576.         my @required = ( 'from', 'to', 'cc', 'subject' );
  577.  
  578.         foreach my $h (@required) {
  579.  
  580.             ${$header{$h}}[0] =
  581.                  $self->{classifier__}->{parser__}->decode_string(
  582.                      ${$header{$h}}[0] );
  583.             
  584.             if ( !defined ${$header{$h}}[0] || ${$header{$h}}[0] =~ /^\s*$/ ) {
  585.                 if ( $h ne 'cc' ) {
  586.                     ${$header{$h}}[0] = "<$h header missing>";
  587.                 } else {
  588.                     ${$header{$h}}[0] = '';
  589.                 }
  590.             }
  591.             
  592.             ${$header{$h}}[0] =~ s/\0//g;
  593.             ${$header{$h}}[0] = $self->db__()->quote( ${$header{$h}}[0] );
  594.         }
  595.  
  596.         # If we do not have a date header then set the date to
  597.         # 0 (start of the Unix epoch), otherwise parse the string
  598.         # using Date::Parse to interpret it and turn it into the
  599.         # Unix epoch.
  600.  
  601.         if ( !defined( ${$header{date}}[0] ) ) {
  602.             ${$header{date}}[0] = 0;
  603.         } else {
  604.             ${$header{date}}[0] = str2time( ${$header{date}}[0] ) || 0;
  605.         }
  606.  
  607.         # Figure out the ID of the bucket this message has been
  608.         # classified into (and the same for the magnet if it is
  609.         # defined)
  610.  
  611.         my $bucketid = $self->{classifier__}->get_bucket_id(
  612.                            $session, $bucket );
  613.  
  614.         my $msg_size = -s $file;
  615.  
  616.         # If we can't get the bucket ID because the bucket doesn't exist
  617.         # which could happen when we are upgrading the history which
  618.         # has old bucket names in it then we will remove the entry from the
  619.         # history and log the failure
  620.  
  621.         if ( defined( $bucketid ) ) {
  622.             my $result = $self->db__()->do(
  623.                 "update history set hdr_from    = ${$header{from}}[0],
  624.                                     hdr_to      = ${$header{to}}[0],
  625.                                     hdr_date    = ${$header{date}}[0],
  626.                                     hdr_cc      = ${$header{cc}}[0],
  627.                                     hdr_subject = ${$header{subject}}[0],
  628.                                     sort_from   = $sort_headers{from},
  629.                                     sort_to     = $sort_headers{to},
  630.                                     sort_cc     = $sort_headers{cc},
  631.                                     committed   = 1,
  632.                                     bucketid    = $bucketid,
  633.                                     usedtobe    = 0,
  634.                                     magnetid    = $magnet,
  635.                                     hash        = $hash,
  636.                                     size        = $msg_size
  637.                                     where id = $slot;" );
  638.         } else {
  639.             $self->log_( 0, "Couldn't find bucket ID for bucket $bucket when committing $slot" );
  640.             $self->release_slot( $slot );
  641.         }
  642.     }
  643.  
  644.     $self->{commit_list__} = ();
  645.     $self->force_requery__();
  646. }
  647.  
  648. # ---------------------------------------------------------------------------
  649. #
  650. # delete_slot
  651. #
  652. # Deletes an entry from the database and disk, optionally archiving it
  653. # if the archive parameters have been set
  654. #
  655. # $slot              The slot ID
  656. # $archive           1 if it's OK to archive this entry
  657. #
  658. # ---------------------------------------------------------------------------
  659. sub delete_slot
  660. {
  661.     my ( $self, $slot, $archive ) = @_;
  662.  
  663.     my $file = $self->get_slot_file( $slot );
  664.     $self->log_( 2, "delete_slot called for slot $slot, file $file" );
  665.  
  666.     if ( $archive && $self->config_( 'archive' ) ) {
  667.         my $path = $self->get_user_path_( $self->config_( 'archive_dir' ), 0 );
  668.  
  669.         $self->make_directory__( $path );
  670.  
  671.         my @b = $self->db__()->selectrow_array(
  672.             "select buckets.name from history, buckets
  673.                  where history.bucketid = buckets.id and
  674.                        history.id = $slot;" );
  675.  
  676.         my $bucket = $b[0];
  677.  
  678.         if ( ( $bucket ne 'unclassified' ) &&
  679.              ( $bucket ne 'unknown class' ) ) {
  680.             $path .= "\/" . $bucket;
  681.             $self->make_directory__( $path );
  682.  
  683.             if ( $self->config_( 'archive_classes' ) > 0) {
  684.  
  685.                 # Archive to a random sub-directory of the bucket archive
  686.  
  687.                 my $subdirectory = int( rand(
  688.                     $self->config_( 'archive_classes' ) ) );
  689.                 $path .= "\/" . $subdirectory;
  690.                 $self->make_directory__( $path );
  691.             }
  692.  
  693.             # Previous comment about this potentially being unsafe
  694.             # (may have placed messages in unusual places, or
  695.             # overwritten files) no longer applies. Files are now
  696.             # placed in the user directory, in the archive_dir
  697.             # subdirectory
  698.  
  699.             $self->copy_file__( $file, $path, "popfile$slot.msg" );
  700.         }
  701.     }
  702.  
  703.     # Now remove the entry from the database, and the file from disk,
  704.     # and also invalidate the caches of any open queries since they
  705.     # may have been affected
  706.  
  707.     $self->release_slot( $slot );
  708.     $self->force_requery__();
  709. }
  710.  
  711. #----------------------------------------------------------------------------
  712. #
  713. # start_deleting
  714. #
  715. # Called before doing a block of calls to delete_slot.  This will call
  716. # back into the Classifier::Bayes to tweak the database performance to
  717. # make this quick.
  718. #
  719. #----------------------------------------------------------------------------
  720. sub start_deleting
  721. {
  722.     my ( $self ) = @_;
  723.  
  724.     $self->{classifier__}->tweak_sqlite( 1, 1, $self->db__() );
  725. }
  726.  
  727. #----------------------------------------------------------------------------
  728. #
  729. # stop_deleting
  730. #
  731. # Called after doing a block of calls to delete_slot.  This will call
  732. # back into the Classifier::Bayes to untweak the database performance.
  733. #
  734. #----------------------------------------------------------------------------
  735. sub stop_deleting
  736. {
  737.     my ( $self ) = @_;
  738.  
  739.     $self->{classifier__}->tweak_sqlite( 1, 0, $self->db__() );
  740. }
  741.  
  742. #----------------------------------------------------------------------------
  743. #
  744. # get_slot_file
  745. #
  746. # Used to map a slot ID to the full path of the file will contain
  747. # the message associated with the slot
  748. #
  749. #----------------------------------------------------------------------------
  750. sub get_slot_file
  751. {
  752.     my ( $self, $slot ) = @_;
  753.  
  754.     # The mapping between the slot and the file goes as follows:
  755.     #
  756.     # 1. Convert the file to an 8 digit hex number (with leading
  757.     #    zeroes).
  758.     # 2. Call that number aabbccdd
  759.     # 3. Build the path aa/bb/cc
  760.     # 4. Name the file popfiledd.msg
  761.     # 5. Add the msgdir location to obtain
  762.     #        msgdir/aa/bb/cc/popfiledd.msg
  763.     #
  764.     # Hence each directory can have up to 256 entries
  765.  
  766.     my $hex_slot = sprintf( '%8.8x', $slot );
  767.     my $path = $self->get_user_path_(
  768.                    $self->global_config_( 'msgdir' ) .
  769.                        substr( $hex_slot, 0, 2 ) . '/', 0 );
  770.  
  771.     $self->make_directory__( $path );
  772.     $path .= substr( $hex_slot, 2, 2 ) . '/';
  773.     $self->make_directory__( $path );
  774.     $path .= substr( $hex_slot, 4, 2 ) . '/';
  775.     $self->make_directory__( $path );
  776.  
  777.     my $file = 'popfile' .
  778.                substr( $hex_slot, 6, 2 ) . '.msg';
  779.  
  780.     return $path . $file;
  781. }
  782.  
  783. #----------------------------------------------------------------------------
  784. #
  785. # get_message_hash
  786. #
  787. # Used to compute an MD5 hash of the headers of a message
  788. # so that the same message can later me identified by a
  789. # call to get_slot_from_hash
  790. #
  791. # messageid              The message id header
  792. # date                   The date header
  793. # subject                The subject header
  794. # received               First Received header line
  795. #
  796. # Note that the values passed in are everything after the : in
  797. # header without the trailing \r or \n.  If a header is missing
  798. # then pass in the empty string
  799. #
  800. #----------------------------------------------------------------------------
  801. sub get_message_hash
  802. {
  803.     my ( $self, $messageid, $date, $subject, $received ) = @_;
  804.  
  805.     $messageid = '' if ( !defined( $messageid ) );
  806.     $date      = '' if ( !defined( $date      ) );
  807.     $subject   = '' if ( !defined( $subject   ) );
  808.     $received  = '' if ( !defined( $received  ) );
  809.  
  810.     return md5_hex( "[$messageid][$date][$subject][$received]" );
  811. }
  812.  
  813. #----------------------------------------------------------------------------
  814. #
  815. # get_slot_from_hash
  816. #
  817. # Given a hash value (returned by get_message_hash), find any
  818. # corresponding message in the database and return its slot
  819. # id.   If the message does not exist then return the empty
  820. # string.
  821. #
  822. # hash                 The hash value
  823. #
  824. #----------------------------------------------------------------------------
  825. sub get_slot_from_hash
  826. {
  827.     my ( $self, $hash ) = @_;
  828.  
  829.     $hash = $self->db__()->quote( $hash );
  830.     my $result = $self->db__()->selectrow_arrayref(
  831.         "select id from history where hash = $hash limit 1;" );
  832.  
  833.     return defined( $result )?$result->[0]:'';
  834. }
  835.  
  836. #----------------------------------------------------------------------------
  837. #
  838. # QUERYING THE HISTORY
  839. #
  840. # 1. Start a query session by calling start_query and obtain a unique
  841. #    ID
  842. #
  843. # 2. Set the query parameter (i.e. sort, search and filter) with a call
  844. #    to set_query
  845. #
  846. # 3. Obtain the number of history rows returned by calling get_query_size
  847. #
  848. # 4. Get segments of the history returned by calling get_query_rows with
  849. #    the start and end rows needed
  850. #
  851. # 5. When finished with the query call stop_query
  852. #
  853. #----------------------------------------------------------------------------
  854.  
  855. #----------------------------------------------------------------------------
  856. #
  857. # start_query
  858. #
  859. # Used to start a query session, returns a unique ID for this
  860. # query.  When the caller is done with the query they return
  861. # stop_query.
  862. #
  863. #----------------------------------------------------------------------------
  864. sub start_query
  865. {
  866.     my ( $self ) = @_;
  867.  
  868.     # Think of a large random number, make sure that it hasn't
  869.     # been used and then return it
  870.  
  871.     while (1) {
  872.         my $id = sprintf( '%8.8x', int(rand(4294967295)) );
  873.  
  874.         if ( !defined( $self->{queries__}{$id} ) ) {
  875.             $self->{queries__}{$id}{query} = 0;
  876.             $self->{queries__}{$id}{count} = 0;
  877.             $self->{queries__}{$id}{cache} = ();
  878.             return $id
  879.         }
  880.     }
  881. }
  882.  
  883. #----------------------------------------------------------------------------
  884. #
  885. # stop_query
  886. #
  887. # Used to clean up after a query session
  888. #
  889. # id                The ID returned by start_query
  890. #
  891. #----------------------------------------------------------------------------
  892. sub stop_query
  893. {
  894.     my ( $self, $id ) = @_;
  895.  
  896.     # If the cache size hasn't grown to the row
  897.     # count then we didn't fetch everything and so
  898.     # we fill call finish to clean up
  899.  
  900.     my $q = $self->{queries__}{$id}{query};
  901.  
  902.     if ( ( defined $q ) && ( $q != 0 ) ) {
  903.         if ( $#{$self->{queries__}{$id}{cache}} !=
  904.              $self->{queries__}{$id}{count} ) {
  905.            $q->finish;
  906.         }
  907.     }
  908.  
  909.     delete $self->{queries__}{$id};
  910. }
  911.  
  912. #----------------------------------------------------------------------------
  913. #
  914. # set_query
  915. #
  916. # Called to set up a query with sort, filter and search options
  917. #
  918. # id            The ID returned by start_query
  919. # filter        Name of bucket to filter on
  920. # search        From/Subject line to search for
  921. # sort          The field to sort on (from, subject, to, cc, bucket, date)
  922. #               (optional leading - for descending sort)
  923. # not           If set to 1 negates the search
  924. #
  925. #----------------------------------------------------------------------------
  926. sub set_query
  927. {
  928.     my ( $self, $id, $filter, $search, $sort, $not ) = @_;
  929.  
  930.     # If this query has already been done and is in the cache
  931.     # then do no work here
  932.  
  933.     if ( defined( $self->{queries__}{$id}{fields} ) &&
  934.          ( $self->{queries__}{$id}{fields} eq
  935.              "$filter:$search:$sort:$not" ) ) {
  936.         return;
  937.     }
  938.  
  939.     $self->{queries__}{$id}{fields} = "$filter:$search:$sort:$not";
  940.  
  941.     # We do two queries, the first to get the total number of rows that
  942.     # would be returned and then we start the real query.  This is done
  943.     # so that we know the size of the resulting data without having
  944.     # to retrieve it all
  945.  
  946.     $self->{queries__}{$id}{base} = 'select XXX from
  947.         history, buckets, magnets where history.userid = 1 and committed = 1';
  948.  
  949.     $self->{queries__}{$id}{base} .= ' and history.bucketid = buckets.id';
  950.     $self->{queries__}{$id}{base} .= ' and magnets.id = magnetid';
  951.  
  952.     # If there's a search portion then add the appropriate clause
  953.     # to find the from/subject header
  954.  
  955.     my $not_word  = $not?'not':'';
  956.     my $not_equal = $not?'!=':'=';
  957.     my $equal     = $not?'=':'!=';
  958.  
  959.     if ( $search ne '' ) {
  960.         $search = $self->db__()->quote( '%' . $search . '%' );
  961.         $self->{queries__}{$id}{base} .= " and $not_word ( hdr_from like $search or hdr_subject like $search )";
  962.     }
  963.  
  964.     # If there's a filter option then we'll need to get the bucket
  965.     # id for the filtered bucket and add the appropriate clause
  966.  
  967.     if ( $filter ne '' ) {
  968.         if ( $filter eq '__filter__magnet' ) {
  969.             $self->{queries__}{$id}{base} .=
  970.                 " and history.magnetid $equal 0";
  971.         } else {
  972.             my $session = $self->{classifier__}->get_session_key(
  973.                               'admin', '' );
  974.             my $bucketid = $self->{classifier__}->get_bucket_id(
  975.                                $session, $filter );
  976.             $self->{classifier__}->release_session_key( $session );
  977.             $self->{queries__}{$id}{base} .=
  978.                 " and history.bucketid $not_equal $bucketid";
  979.         }
  980.     }
  981.  
  982.     # Add the sort option (if there is one)
  983.  
  984.     if ( $sort ne '' ) {
  985.         $sort =~ s/^(\-)//;
  986.         my $direction = defined($1)?'desc':'asc';
  987.         if ( $sort eq 'bucket' ) {
  988.             $sort = 'buckets.name';
  989.         } else {
  990.             if ( $sort =~ /from|to|cc/ ) {
  991.                 $sort = "sort_$sort";
  992.             } else {
  993.                 if ( $sort ne 'inserted' && $sort ne 'size' ) {
  994.                     $sort = "hdr_$sort";
  995.                 }
  996.             }
  997.         }
  998.         $self->{queries__}{$id}{base} .= " order by $sort $direction;";
  999.     } else {
  1000.         $self->{queries__}{$id}{base} .= ' order by inserted desc;';
  1001.     }
  1002.  
  1003.     my $count = $self->{queries__}{$id}{base};
  1004.     $self->log_( 2, "Base query is $count" );
  1005.     $count =~ s/XXX/COUNT(*)/;
  1006.  
  1007.     $self->{queries__}{$id}{count} =
  1008.         $self->db__()->selectrow_arrayref( $count )->[0];
  1009.  
  1010.     my $select = $self->{queries__}{$id}{base};
  1011.     $select =~ s/XXX/$fields_slot/;
  1012.     $self->{queries__}{$id}{query} = $self->db__()->prepare( $select );
  1013.     $self->{queries__}{$id}{query}->execute;
  1014.     $self->{queries__}{$id}{cache} = ();
  1015. }
  1016.  
  1017. #----------------------------------------------------------------------------
  1018. #
  1019. # delete_query
  1020. #
  1021. # Called to delete all the rows returned in a query
  1022. #
  1023. # id            The ID returned by start_query
  1024. #
  1025. #----------------------------------------------------------------------------
  1026. sub delete_query
  1027. {
  1028.     my ( $self, $id ) = @_;
  1029.  
  1030.     $self->start_deleting();
  1031.  
  1032.     my $delete = $self->{queries__}{$id}{base};
  1033.     $delete =~ s/XXX/history.id/;
  1034.     my $d = $self->db__()->prepare( $delete );
  1035.     $d->execute;
  1036.     my @row;
  1037.     my @ids;
  1038.     while ( @row = $d->fetchrow_array ) {
  1039.         push ( @ids, $row[0] );
  1040.     }
  1041.     foreach my $id (@ids) {
  1042.         $self->delete_slot( $id, 1 );
  1043.     }
  1044.  
  1045.     $self->stop_deleting();
  1046. }
  1047.  
  1048. #----------------------------------------------------------------------------
  1049. #
  1050. # get_query_size
  1051. #
  1052. # Called to return the number of elements in the query.
  1053. # Should only be called after a call to set_query.
  1054. #
  1055. # id            The ID returned by start_query
  1056. #
  1057. #----------------------------------------------------------------------------
  1058. sub get_query_size
  1059. {
  1060.     my ( $self, $id ) = @_;
  1061.  
  1062.     return $self->{queries__}{$id}{count};
  1063. }
  1064.  
  1065. #----------------------------------------------------------------------------
  1066. #
  1067. # get_query_rows
  1068. #
  1069. # Returns the rows in the range [$start, $end) from a query that has
  1070. # already been set up with a call to set_query.  The first row is row 1.
  1071. #
  1072. # id            The ID returned by start_query
  1073. # start         The first row to return
  1074. # count         Number of rows to return
  1075. #
  1076. # Each row contains the fields:
  1077. #
  1078. #    id (0), from (1), to (2), cc (3), subject (4), date (5), hash (6),
  1079. #    inserted date (7), bucket name (8), reclassified id (9), bucket id (10),
  1080. #    magnet value (11), size (12)
  1081. #----------------------------------------------------------------------------
  1082. sub get_query_rows
  1083. {
  1084.     my ( $self, $id, $start, $count ) = @_;
  1085.  
  1086.     # First see if we have already retrieved these rows from the query
  1087.     # if we have then we can just return them from the cache.  Otherwise
  1088.     # fetch the rows from the database and then return them
  1089.  
  1090.     my $size = $#{$self->{queries__}{$id}{cache}}+1;
  1091.  
  1092.     $self->log_( 2, "Request for rows $start ($count), current size $size" );
  1093.  
  1094.     if ( ( $size < ( $start + $count - 1 ) ) ) {
  1095.         my $rows = $start + $count - $size;
  1096.         $self->log_( 2, "Getting $rows rows from database" );
  1097.         push ( @{$self->{queries__}{$id}{cache}},
  1098.             @{$self->{queries__}{$id}{query}->fetchall_arrayref(
  1099.                 undef, $start + $count - $size )} );
  1100.     }
  1101.  
  1102.     my ( $from, $to ) = ( $start-1, $start+$count-2 );
  1103.  
  1104.     $self->log_( 2, "Returning $from..$to" );
  1105.  
  1106.     return @{$self->{queries__}{$id}{cache}}[$from..$to];
  1107. }
  1108.  
  1109. # ---------------------------------------------------------------------------
  1110. #
  1111. # make_directory__
  1112. #
  1113. # Wrapper for mkdir that ensures that the path we are making doesn't end in
  1114. # / or \ (Done because your can't do mkdir 'foo/' on NextStep.
  1115. #
  1116. # $path        The directory to make
  1117. #
  1118. # Returns whatever mkdir returns
  1119. #
  1120. # ---------------------------------------------------------------------------
  1121. sub make_directory__
  1122. {
  1123.     my ( $self, $path ) = @_;
  1124.  
  1125.     $path =~ s/[\\\/]$//;
  1126.  
  1127.     return 1 if ( -d $path );
  1128.     return mkdir( $path );
  1129. }
  1130.  
  1131. # ---------------------------------------------------------------------------
  1132. #
  1133. # compare_mf__
  1134. #
  1135. # Compares two mailfiles, used for sorting mail into order
  1136. #
  1137. # ---------------------------------------------------------------------------
  1138. sub compare_mf__
  1139. {
  1140.     $a =~ /popfile(\d+)=(\d+)\.msg/;
  1141.     my ( $ad, $am ) = ( $1, $2 );
  1142.  
  1143.     $b =~ /popfile(\d+)=(\d+)\.msg/;
  1144.     my ( $bd, $bm ) = ( $1, $2 );
  1145.  
  1146.     if ( $ad == $bd ) {
  1147.         return ( $bm <=> $am );
  1148.     } else {
  1149.         return ( $bd <=> $ad );
  1150.     }
  1151. }
  1152.  
  1153. # ---------------------------------------------------------------------------
  1154. #
  1155. # upgrade_history_files__
  1156. #
  1157. # Looks for old .MSG/.CLS history entries and sticks them in the database
  1158. #
  1159. # ---------------------------------------------------------------------------
  1160. sub upgrade_history_files__
  1161. {
  1162.     my ( $self ) = @_;
  1163.  
  1164.     # See if there are any .MSG files in the msgdir, and if there are
  1165.     # upgrade them by placing them in the database
  1166.  
  1167.     my @msgs = sort compare_mf__ glob $self->get_user_path_(
  1168.         $self->global_config_( 'msgdir' ) . 'popfile*.msg', 0 );
  1169.  
  1170.     if ( $#msgs != -1 ) {
  1171.         my $session = $self->{classifier__}->get_session_key( 'admin', '' );
  1172.  
  1173.         print "\nFound old history files, moving them into database\n    ";
  1174.  
  1175.         my $i = 0;
  1176.         $self->db__()->begin_work;
  1177.         foreach my $msg (@msgs) {
  1178.             if ( ( ++$i % 100 ) == 0 ) {
  1179.                 print "[$i]";
  1180.                 flush STDOUT;
  1181.             }
  1182.  
  1183.             # NOTE.  We drop the information in $usedtobe, so that
  1184.             # reclassified messages will no longer appear reclassified
  1185.             # in upgraded history.  Also the $magnet is ignored so
  1186.             # upgraded history will have no magnet information.
  1187.  
  1188.             my ( $reclassified, $bucket, $usedtobe, $magnet ) =
  1189.                 $self->history_read_class__( $msg );
  1190.  
  1191.             if ( $bucket ne 'unknown_class' ) {
  1192.                 my ( $slot, $file ) = $self->reserve_slot();
  1193.                 rename $msg, $file;
  1194.                 my @message = ( $session, $slot, $bucket, 0 );
  1195.                 push ( @{$self->{commit_list__}}, \@message );
  1196.             }
  1197.         }
  1198.         $self->db__()->commit;
  1199.  
  1200.         print "\nDone upgrading history\n";
  1201.  
  1202.         $self->commit_history__();
  1203.         $self->{classifier__}->release_session_key( $session );
  1204.  
  1205.         unlink $self->get_user_path_(
  1206.             $self->global_config_( 'msgdir' ) . 'history_cache', 0 );
  1207.     }
  1208. }
  1209.  
  1210. # ---------------------------------------------------------------------------
  1211. #
  1212. # history_read_class__ - load and delete the class file for a message.
  1213. #
  1214. # returns: ( reclassified, bucket, usedtobe, magnet )
  1215. #   values:
  1216. #       reclassified:   boolean, true if message has been reclassified
  1217. #       bucket:         string, the bucket the message is in presently,
  1218. #                       unknown class if an error occurs
  1219. #       usedtobe:       string, the bucket the message used to be in
  1220. #                       (null if not reclassified)
  1221. #       magnet:         string, the magnet
  1222. #
  1223. # $filename     The name of the message to load the class for
  1224. #
  1225. # ---------------------------------------------------------------------------
  1226. sub history_read_class__
  1227. {
  1228.     my ( $self, $filename ) = @_;
  1229.  
  1230.     $filename =~ s/msg$/cls/;
  1231.  
  1232.     my $reclassified = 0;
  1233.     my $bucket = 'unknown class';
  1234.     my $usedtobe;
  1235.     my $magnet = '';
  1236.  
  1237.     if ( open CLASS, "<$filename" ) {
  1238.         $bucket = <CLASS>;
  1239.         if ( defined( $bucket ) &&
  1240.            ( $bucket =~ /([^ ]+) MAGNET ([^\r\n]+)/ ) ) {
  1241.             $bucket = $1;
  1242.             $magnet = $2;
  1243.         }
  1244.  
  1245.         $reclassified = 0;
  1246.         if ( defined( $bucket ) && ( $bucket =~ /RECLASSIFIED/ ) ) {
  1247.             $bucket       = <CLASS>;
  1248.             $usedtobe = <CLASS>;
  1249.             $reclassified = 1;
  1250.             $usedtobe =~ s/[\r\n]//g;
  1251.         }
  1252.         close CLASS;
  1253.         $bucket =~ s/[\r\n]//g if defined( $bucket );
  1254.         unlink $filename;
  1255.     } else {
  1256.         return ( undef, $bucket, undef, undef );
  1257.     }
  1258.  
  1259.     $bucket = 'unknown class' if ( !defined( $bucket ) );
  1260.  
  1261.     return ( $reclassified, $bucket, $usedtobe, $magnet );
  1262. }
  1263.  
  1264. #----------------------------------------------------------------------------
  1265. #
  1266. # cleanup_history
  1267. #
  1268. # Removes the popfile*.msg files that are older than a number of days
  1269. # configured as history_days.
  1270. #
  1271. #----------------------------------------------------------------------------
  1272. sub cleanup_history
  1273. {
  1274.     my ( $self ) = @_;
  1275.  
  1276.     my $seconds_per_day = 24 * 60 * 60;
  1277.     my $old = time - $self->config_( 'history_days' ) * $seconds_per_day;
  1278.     my $d = $self->db__()->prepare( "select id from history
  1279.                                          where inserted < $old;" );
  1280.     $d->execute;
  1281.     my @row;
  1282.     my @ids;
  1283.     while ( @row = $d->fetchrow_array ) {
  1284.         push ( @ids, $row[0] );
  1285.     }
  1286.     foreach my $id (@ids) {
  1287.         $self->delete_slot( $id, 1 );
  1288.     }
  1289. }
  1290.  
  1291. # ---------------------------------------------------------------------------
  1292. #
  1293. # copy_file__
  1294. #
  1295. # Utility to copy a file and ensure that the path it is going to
  1296. # exists
  1297. #
  1298. # $from               Where to copy from
  1299. # $to_dir             The directory it will be copied to
  1300. # $to_name            The name of the destination (without the directory)
  1301. #
  1302. # ---------------------------------------------------------------------------
  1303. sub copy_file__
  1304. {
  1305.     my ( $self, $from, $to_dir, $to_name ) = @_;
  1306.  
  1307.     if ( open( FROM, "<$from") ) {
  1308.         if ( open( TO, ">$to_dir\/$to_name") ) {
  1309.             binmode FROM;
  1310.             binmode TO;
  1311.             while (<FROM>) {
  1312.                 print TO $_;
  1313.             }
  1314.             close TO;
  1315.         }
  1316.  
  1317.         close FROM;
  1318.     }
  1319. }
  1320.  
  1321. # ---------------------------------------------------------------------------
  1322. #
  1323. # force_requery__
  1324. #
  1325. # Called when the database has changed to invalidate any queries that are
  1326. # open so that cached data is not returned and the database is requeried
  1327. #
  1328. # ---------------------------------------------------------------------------
  1329. sub force_requery__
  1330. {
  1331.     my ( $self ) = @_;
  1332.     # Force requery since the messages have changed
  1333.  
  1334.     foreach my $id (keys %{$self->{queries__}}) {
  1335.         $self->{queries__}{$id}{fields} = '';
  1336.     }
  1337. }
  1338.  
  1339. # SETTER
  1340.  
  1341. sub classifier
  1342. {
  1343.     my ( $self, $classifier ) = @_;
  1344.  
  1345.     $self->{classifier__} = $classifier;
  1346. }
  1347.  
  1348. 1;
  1349.